home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / yerk 3.66 / Float source / fpi⁄o < prev    next >
Text File  |  1994-06-24  |  7KB  |  201 lines
  1. \ FPI/O -- floating-point I/O support for 68000 SANE engine.
  2. \    5/11/85     ssg Version 1.0
  3. \    9/26/85     cbd Modified for float heap, removed minor methods
  4. \    2/07/86     gdc Added words atof and f.r, changed eprint to eprint, printxyz
  5. \    8/16/86     cdn Eliminated finit & Stringer shorten
  6. \    5/26/91     rfl Eliminated Stringer class altogether.
  7. \ 10/26/91    rfl abs in front of /mod
  8. \ 12/17/92    rfl fixed a few problems that might occur due to not locking handles
  9. \ 01/26/93    rfl protect parse: to reject a possible float if 2 decimal points are mistakenly
  10. \                 adjacent. The case of " 1.234.56" is interpreted as an integer
  11. \ 12/03/93    rfl fixed problem with non FPU machines returning garbage exp when
  12. \                0 is passed to num2dec in float2dec:. Thanks to Harry Haddon.
  13. \                Removed 2 bytes scratch -use pad instead. Removed if true else false
  14. \ 12/05/93    rfl    Rewrote much of the formatting routines and added ability to
  15. \                get addr len of format on stack. More use of pack7 utilities.
  16.  
  17. Decimal
  18.  
  19. \ Some useful constants
  20. 256 constant neg
  21.     0 constant pos
  22. 256 constant FixedDecimal
  23.     0 constant FloatDecimal
  24.     0 value topxyz                \ top of string being converted to float
  25.  
  26. 0 variable valid?            \ used for scan: but never used otherwise...mhore
  27.  
  28. \ reentrant code to get rid of leading zeros - not used here
  29. \ : endZ ( addr -- addr) dup c@ ascii 0 = IF 1+ endZ THEN ;
  30.  
  31. :CLASS        FPI/O    <Super Object
  32.  
  33.             \ SANE Record Decimal ( x:= (-1)^sgn * 10^exp * SigDig )
  34.             INT sgn        \ sign; 0=pos, 256=neg
  35.             INT exp        \ as if decimal point were to the right of SigDig
  36.             22 BYTES SigDig \ to fake string[20] ; 22 to make even
  37.  
  38.             \ SANE Record DecForm
  39.             INT style    \ Float=0; Fixed=256
  40.             INT digits    \ # of sig digits,if float; # dec. places,if fixed.
  41.  
  42.             string     floater         \ to hold formatted output string
  43.             string     expStr            \ to hold formatted exponent string
  44.             var         places            \ number of places to right of dec. pt.
  45.  
  46.             int index
  47.  
  48. ( -- )
  49.   :M    CLEAR:    addr: sgn 26 erase unlock: floater clear: floater clear: expstr ;M
  50.  
  51. ( -- )    \ Initialize strings etc.
  52.   :M    INIT:    new: floater new: expStr clear: self ;M
  53.  
  54. ( -- )
  55.   :M    EINIT:    clear: self FloatDecimal put: style ( 19 put: digits)    ;M
  56.  
  57. ( -- )    \ Initialize for fixed conversion
  58.   :M    FINIT:    clear: self FixedDecimal put: style        ;M
  59.  
  60. ( -- )    \ Puts a zero in decimal record
  61.   :M    ZERO:    clear: self     $ 0130 addr: sigDig w!        ;M
  62.  
  63. ( -- float )    \ ==== attempt to convert decimal to a float;
  64.   :M    DEC2FLOAT:    { \ flt     -- flt }
  65.         abs: sgn    \ Addr of decimal record
  66.         new: fltMem -> flt    flt 2+ +base    \ Absolute Destination address
  67.         $ 0009 \ FFEXT FOD2B + -- Opcode for decimal to binary; dest=extended
  68.         fp68k        flt            \ Call FP68K
  69.     ;M
  70.  
  71. ( float -- )            \ ==== convert float to decimal     ==== \
  72.   :M    FLOAT2DEC:    { flt -- }
  73.         abs: style     \ Absolute Addr of Decform record
  74.         flt 2+ +base            \ Absolute Addr of source
  75.         abs: sgn    \ Absolute Addr of Decimal record
  76.         $ 000b \ FFEXT FOB2D + -- Opcode for binary to decimal; source=extended
  77.         fp68k    flt fdrop        \ Call FP68K, dispose of float
  78. \         addr: sigDig 1+ c@ ascii 0 =
  79. \         IF clear: exp THEN
  80.     ;M
  81.  
  82. ( -- )    \ Set up float for in decimal record in scientific format,
  83. \                            left-justified in a field of width characters.
  84.   :M    num2dec: float2dec: self
  85.         abs: style (abs) pad +base call dec2str
  86.         pad count put: floater ;M
  87.  
  88.   :M    ROUND: ( f -- f') 1 swap 0 do 10 * LOOP >float fdup >r f* round r> f/ ;M
  89.  
  90. ( flt width -- addr len)
  91.   :M    GETEText: { width \ pos -- addr len } 
  92.             einit: self
  93.             num2dec: self
  94.             start: floater ascii e charof: floater
  95.             IF drop size: floater substr: floater put: expStr
  96.                 width size: expStr - 3 max                \ bl or -, digit, decimal minimum
  97.                 size: floater size: expStr - min -> pos \ keep at least 2 numbers for decimal
  98.  
  99.                 pos moveto: floater                    \ round up NEED
  100.  
  101.                 size: floater substr: floater get: expStr replace: floater
  102.             ELSE addr: sigDig count drop c@
  103.                 dup ascii I = IF pad 1+ 1 put: floater
  104.                                 " Infinity" add: floater
  105.                                  width 10 - 0 DO bl +: floater LOOP
  106.                                 THEN
  107.                     ascii N = IF pad 1+ 1 put: floater width 14 >
  108.                                 IF " Not a number " add: floater
  109.                                      width 14 - 
  110.                                 ELSE " NaN " add: floater
  111.                                      width 5 -
  112.                                 THEN 
  113.                                 0 DO bl +: floater LOOP
  114.                                 THEN
  115.             THEN    lock: floater get: floater ;M
  116.  
  117.   :M EPRINT: geteText: self type ;M
  118.                                  \ Carry out f.r
  119.   :M GETFText: { width decimal \ dot -- addr len }
  120.     finit: self
  121.     decimal round: self num2dec: self
  122.     start: floater ascii . charof: floater
  123.     IF -> dot
  124.         decimal abs 1+ subStr: floater put: expStr
  125.         get: sgn not IF start: floater bl pad c! pad 1 insert: floater 1 ++> dot THEN
  126.         dot moveto: floater
  127.         size: floater substr: floater get: expStr replace: floater
  128.         size: floater width <
  129.         IF bl width size: floater -     fill: expStr
  130.             start: floater get: expStr insert: floater
  131.         THEN
  132.     ELSE addr: sigDig count drop c@
  133.         dup ascii I = IF get: sgn
  134.                         IF ascii - ELSE bl THEN pad c! pad 1 put: floater
  135.                          " Infinity" add: floater
  136.                          width 10 - 0 DO bl +: floater LOOP
  137.                         THEN
  138.             ascii N = IF get: sgn
  139.                             IF ascii - ELSE bl THEN pad c! pad 1 put: floater
  140.                             width 14 >
  141.                             IF " Not a number " add: floater width 14 -
  142.                             ELSE " NaN " add: floater width 5 -
  143.                             THEN 0 DO bl +: floater LOOP
  144.                         THEN
  145.             
  146.     THEN lock: floater get: floater ;M
  147.  
  148.   :M FPRINT: getFText: self type ;M
  149.  
  150.   :M SCAN: ( addr len --) str255 -base dup c@ 2+ padbl
  151.         buf255 +base 1+ clear: index abs: index (abs) valid? 3+ +base
  152.         call PStr2Dec ;M
  153.   :M CONV?: { addr len -- b } addr len scan: self get: index len = ;M
  154.  
  155. \ str255 format at addr
  156.   :M ATOF: ( addr -- f t | f )
  157.         count conv?: self     IF dec2float: self true ELSE false THEN ;M
  158.  
  159. :M classinit: 19 put: digits ;M
  160.  
  161. ;Class
  162.  
  163. fpi/o floati/o            \ The default fpi/o object
  164. init: floati/o
  165.  
  166. ( width -- )
  167. ( flt -- )    \ Print a float in scientific format in a field of width chars.
  168. : e.r    ( flt width -- ) eprint: floati/o    ;
  169.  
  170. ( flt -- )    \ Print a float in scientific format.
  171. : e.    26 e.r ;
  172.  
  173. ( addr len -- fval T ) \    Successful        \ Converts a relative str255 string
  174. ( addr len -- F )        \    Unsuccessful    \ into a floating point number.
  175. : atof ( addr len -- f t | f )
  176.     str255 -base atof: floati/o ;
  177.  
  178. ( flt width decimal -- )    \ Print a float without exponents, in a field of
  179.                             \ width wide and of decimal places
  180. : f.r     ( flt width decimal -- ) fprint: floati/o ;
  181.  
  182. \ testing
  183. \ int index
  184. \ 0 variable valid?
  185. \ : scan str255 -base dup c@ 2+ padbl
  186. \    buf255 +base 1+ clear: index abs: index abs: floati/o valid? 3+ +base call PStr2Dec ;
  187. \ : conv { addr len -- f t | f } addr len scan get: index len = ;
  188.  
  189. \ : sgn floati/o get: int ;
  190. \ : exp floati/o 2+ get: int ;
  191. \ : sigdig floati/o 4+ count type ;
  192. \ : style floati/o 26 + get: int ;
  193. \ : digits floati/o 28 + get: int ;
  194. \ floati/o 30 + @ string floater floater !
  195. \ floati/o 38 + @ string expStr expStr !
  196. \ : places floati/o 46 + get: var ;
  197.  
  198.  
  199.  
  200.  
  201.